home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / colorlab / modhslsm.bas < prev    next >
BASIC Source File  |  1999-09-28  |  9KB  |  283 lines
  1. Attribute VB_Name = "modHSL"
  2. Option Explicit
  3.  
  4. 'For the FULL version of this module, please visit
  5. ' http://www.planet-source-code.com/vb
  6. '(The darken & brighten routines in this module are
  7. 'slightly modified from that version)
  8.  
  9. 'Portions of this code marked with *** are converted from
  10. 'C/C++ routines for RGB/HSL conversion found in the
  11. 'Microsoft Knowledge Base (PD sample code):
  12. 'http://support.microsoft.com/support/kb/articles/Q29/2/40.asp
  13. 'In addition to the language conversion, some internal
  14. 'calculations have been modified and converted to FP math to
  15. 'reduce rounding errors.
  16. 'Conversion to VB and original code by
  17. 'Dan Redding (bwsoft@revealed.net)
  18. 'http://home.revealed.net/bwsoft
  19. 'Free to use, please give proper credit
  20.  
  21. Public Const HSLMAX As Integer = 240 '***
  22.     'H, S and L values can be 0 - HSLMAX
  23.     '240 matches what is used by MS Win;
  24.     'any number less than 1 byte is OK;
  25.     'works best if it is evenly divisible by 6
  26. Const RGBMAX As Integer = 255 '***
  27.     'R, G, and B value can be 0 - RGBMAX
  28. Const UNDEFINED As Integer = (HSLMAX * 2 / 3) '***
  29.     'Hue is undefined if Saturation = 0 (greyscale)
  30.  
  31. Public Type HSLCol 'Datatype used to pass HSL Color values
  32.     Hue As Integer
  33.     Sat As Integer
  34.     Lum As Integer
  35. End Type
  36.  
  37. Public Function RGBRed(RGBCol As Long) As Integer
  38. 'Return the Red component from an RGB Color
  39.     RGBRed = RGBCol And &HFF
  40. End Function
  41.  
  42. Public Function RGBGreen(RGBCol As Long) As Integer
  43. 'Return the Green component from an RGB Color
  44.     RGBGreen = ((RGBCol And &H100FF00) / &H100)
  45. End Function
  46.  
  47. Public Function RGBBlue(RGBCol As Long) As Integer
  48. 'Return the Blue component from an RGB Color
  49.     RGBBlue = (RGBCol And &HFF0000) / &H10000
  50. End Function
  51.  
  52. Private Function iMax(a As Integer, B As Integer) _
  53.     As Integer
  54. 'Return the Larger of two values
  55.     iMax = IIf(a > B, a, B)
  56. End Function
  57.  
  58. Private Function iMin(a As Integer, B As Integer) _
  59.     As Integer
  60. 'Return the smaller of two values
  61.     iMin = IIf(a < B, a, B)
  62. End Function
  63.  
  64. Public Function RGBtoHSL(RGBCol As Long) As HSLCol '***
  65. 'Returns an HSLCol datatype containing Hue, Luminescence
  66. 'and Saturation; given an RGB Color value
  67.  
  68. Dim R As Integer, G As Integer, B As Integer
  69. Dim cMax As Integer, cMin As Integer
  70. Dim RDelta As Double, GDelta As Double, _
  71.     BDelta As Double
  72. Dim H As Double, s As Double, L As Double
  73. Dim cMinus As Long, cPlus As Long
  74.     
  75.     R = RGBRed(RGBCol)
  76.     G = RGBGreen(RGBCol)
  77.     B = RGBBlue(RGBCol)
  78.     
  79.     cMax = iMax(iMax(R, G), B) 'Highest and lowest
  80.     cMin = iMin(iMin(R, G), B) 'color values
  81.     
  82.     cMinus = cMax - cMin 'Used to simplify the
  83.     cPlus = cMax + cMin  'calculations somewhat.
  84.     
  85.     'Calculate luminescence (lightness)
  86.     L = ((cPlus * HSLMAX) + RGBMAX) / (2 * RGBMAX)
  87.     
  88.     If cMax = cMin Then 'achromatic (r=g=b, greyscale)
  89.         s = 0 'Saturation 0 for greyscale
  90.         H = UNDEFINED 'Hue undefined for greyscale
  91.     Else
  92.         'Calculate color saturation
  93.         If L <= (HSLMAX / 2) Then
  94.             s = ((cMinus * HSLMAX) + 0.5) / cPlus
  95.         Else
  96.             s = ((cMinus * HSLMAX) + 0.5) / (2 * RGBMAX - cPlus)
  97.         End If
  98.     
  99.         'Calculate hue
  100.         RDelta = (((cMax - R) * (HSLMAX / 6)) + 0.5) / cMinus
  101.         GDelta = (((cMax - G) * (HSLMAX / 6)) + 0.5) / cMinus
  102.         BDelta = (((cMax - B) * (HSLMAX / 6)) + 0.5) / cMinus
  103.     
  104.         Select Case cMax
  105.             Case CLng(R)
  106.                 H = BDelta - GDelta
  107.             Case CLng(G)
  108.                 H = (HSLMAX / 3) + RDelta - BDelta
  109.             Case CLng(B)
  110.                 H = ((2 * HSLMAX) / 3) + GDelta - RDelta
  111.         End Select
  112.         
  113.         If H < 0 Then H = H + HSLMAX
  114.     End If
  115.     
  116.     RGBtoHSL.Hue = CInt(H)
  117.     RGBtoHSL.Lum = CInt(L)
  118.     RGBtoHSL.Sat = CInt(s)
  119. End Function
  120.  
  121. Public Function HSLtoRGB(HueLumSat As HSLCol) As Long '***
  122.     Dim R As Double, G As Double, B As Double
  123.     Dim H As Double, L As Double, s As Double
  124.     Dim Magic1 As Double, Magic2 As Double
  125.     
  126.     H = HueLumSat.Hue
  127.     L = HueLumSat.Lum
  128.     s = HueLumSat.Sat
  129.     
  130.     If CInt(s) = 0 Then 'Greyscale
  131.         R = (L * RGBMAX) / HSLMAX 'luminescence,
  132.                 'converted to the proper range
  133.         G = R 'All RGB values same in greyscale
  134.         B = R
  135.         If CInt(H) <> UNDEFINED Then
  136.             'This is technically an error.
  137.             'The RGBtoHSL routine will always return
  138.             'Hue = UNDEFINED (160 when HSLMAX is 240)
  139.             'when Sat = 0.
  140.             'if you are writing a color mixer and
  141.             'letting the user input color values,
  142.             'you may want to set Hue = UNDEFINED
  143.             'in this case.
  144.         End If
  145.     Else
  146.         'Get the "Magic Numbers"
  147.         If L <= HSLMAX / 2 Then
  148.             Magic2 = (L * (HSLMAX + s) + 0.5) / HSLMAX
  149.         Else
  150.             Magic2 = L + s - ((L * s) + 0.5) / HSLMAX
  151.         End If
  152.         
  153.         Magic1 = 2 * L - Magic2
  154.         
  155.         'get R, G, B; change units from HSLMAX range
  156.         'to RGBMAX range
  157.         R = (HuetoRGB(Magic1, Magic2, H + (HSLMAX / 3)) _
  158.             * RGBMAX + 0.5) / HSLMAX
  159.         G = (HuetoRGB(Magic1, Magic2, H) * RGBMAX + 0.5) / HSLMAX
  160.         B = (HuetoRGB(Magic1, Magic2, H - (HSLMAX / 3)) _
  161.             * RGBMAX + 0.5) / HSLMAX
  162.         
  163.     End If
  164.     
  165.     HSLtoRGB = RGB(CInt(R), CInt(G), CInt(B))
  166.     
  167. End Function
  168.  
  169. Private Function HuetoRGB(mag1 As Double, mag2 As Double, _
  170.     ByVal Hue As Double) As Double '***
  171. 'Utility function for HSLtoRGB
  172.  
  173. 'Range check
  174.     If Hue < 0 Then
  175.         Hue = Hue + HSLMAX
  176.     ElseIf Hue > HSLMAX Then
  177.         Hue = Hue - HSLMAX
  178.     End If
  179.     
  180.     'Return r, g, or b value from parameters
  181.     Select Case Hue 'Values get progressively larger.
  182.                 'Only the first true condition will execute
  183.         Case Is < (HSLMAX / 6)
  184.             HuetoRGB = (mag1 + (((mag2 - mag1) * Hue + _
  185.                 (HSLMAX / 12)) / (HSLMAX / 6)))
  186.         Case Is < (HSLMAX / 2)
  187.             HuetoRGB = mag2
  188.         Case Is < (HSLMAX * 2 / 3)
  189.             HuetoRGB = (mag1 + (((mag2 - mag1) * _
  190.                 ((HSLMAX * 2 / 3) - Hue) + _
  191.                 (HSLMAX / 12)) / (HSLMAX / 6)))
  192.         Case Else
  193.             HuetoRGB = mag1
  194.     End Select
  195. End Function
  196.  
  197. Public Function ContrastingColor(RGBCol As Long) As Long
  198. 'Returns Black or White, whichever will show up better
  199. 'on the specified color.
  200. 'Useful for setting label forecolors with transparent
  201. 'backgrounds (send it the form backcolor - RGB value, not
  202. 'system value!)
  203. '(also produces a monochrome negative when applied to
  204. 'all pixels in an image)
  205.  
  206. Dim HSL As HSLCol
  207.     HSL = RGBtoHSL(RGBCol)
  208.     If HSL.Lum > HSLMAX / 2 Then ContrastingColor = 0 _
  209.         Else: ContrastingColor = &HFFFFFF
  210. End Function
  211.  
  212. Public Function Brighten(RGBColor As Long, Percent As Single)
  213. 'Lightens the color by a specifie percent, given as a Single
  214. '(10% = .10)
  215.  
  216. Dim HSL As HSLCol, L As Long
  217.     If Percent <= 0 Then
  218.         Brighten = RGBColor
  219.         Exit Function
  220.     End If
  221.     
  222.     HSL = RGBtoHSL(RGBColor)
  223.     L = HSL.Lum + (HSLMAX * Percent)
  224.     If L > HSLMAX Then L = HSLMAX
  225.     HSL.Lum = L
  226.     Brighten = HSLtoRGB(HSL)
  227. End Function
  228.  
  229. Public Function Darken(RGBColor As Long, Percent As Single)
  230. 'Darkens the color by a specifie percent, given as a Single
  231.  
  232. Dim HSL As HSLCol, L As Long
  233.     If Percent <= 0 Then
  234.         Darken = RGBColor
  235.         Exit Function
  236.     End If
  237.     
  238.     HSL = RGBtoHSL(RGBColor)
  239.     L = HSL.Lum - (HSLMAX * Percent)
  240.     If L < 0 Then L = 0
  241.     HSL.Lum = L
  242.     Darken = HSLtoRGB(HSL)
  243. End Function
  244.  
  245. Public Function Blend(RGB1 As Long, RGB2 As Long, _
  246.     Percent As Single) As Long
  247. 'This one doesn't really use the HSL routines, just the
  248. 'RGB Component routines.  I threw it in as a bonus ;)
  249. 'Takes two colors and blends them according to a
  250. 'percentage given as a Single
  251. 'For example, .3 will return a color 30% of the way
  252. 'between the first color and the second.
  253. '.5, or 50%, will be an even blend (halfway)
  254. 'Can create some nice effects inside a For loo